home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / SYS_TOOL / CALL32NT / CALL32NT.PAS next >
Pascal/Delphi Source File  |  1995-06-27  |  14KB  |  396 lines
  1. Unit Call32nt;
  2. {Delphi/TPW/BPW Unit to call 32-bit functions from 16 bit programs}
  3. {Written in Turbo Pascal for Windows 1.5 /Delphi}
  4. {By Christian Ghisler, CIS: 100332,1175         }
  5. {Released to the public domain on June 14,1995  }
  6.  
  7. {$W-}
  8. {No Windows Stack frame!}
  9. {$R-}
  10. {No range checking!}
  11.  
  12. {
  13. Translation by Christian Ghisler, from:
  14. //----------------------------------------------------------
  15. // CALL32.C
  16. //
  17. // This creates a DLL for 16-bit Visual Basic programs to
  18. // call 32-bit DLLs on Windows NT 3.1.  It uses the 
  19. // Generic Thunks feature of the WOW subsystem on Windows
  20. // NT to load and call 32 bit DLLs.  This file should
  21. // be compile into a 16-bit DLL.
  22. //
  23. // Writted by Peter Golde.
  24. //----------------------------------------------------------
  25. }
  26. interface
  27.  
  28. uses wintypes,
  29.      winprocs,
  30.      {$ifdef ver80}sysutils {$else} strings {$endif};
  31.  
  32. const Call32NTError:boolean=false;
  33.  
  34. type tPROC32ENTRY=record
  35.     hinst:longint;      { 32-bit instance handle of library                  }
  36.     lpfunc:tfarproc;    { 32-bit function address of function                }
  37.     dwAddrXlat,         { bit mask of params: 1 indicates arg is address     }
  38.     dwHwndXlat,         { bit mask of params: 1 indicates arg is 16-bit hwnd }
  39.     nParams:longint;    { number of parameters                               }
  40.   end;
  41.   pPROC32ENTRY=^tPROC32ENTRY;
  42.   tPROC32LIST=array[0..0] of tPROC32ENTRY;
  43.   pPROC32LIST=^tPROC32LIST;
  44.  
  45. { rgProc32Entry points to an array of PROC32ENTRY functions, which
  46.   is grown as needed.  The value returned by Declare32 is an
  47.   index into this array.}
  48. const
  49.   cRegistered:integer=0;          { number of registered functions. }
  50.   cAlloc:integer=0;               { number of alloced PROC32ENTRY structures. }
  51.   rgPROC32ENTRY:pPROC32LIST=nil;  { array of PROC32ENTRY structures. }
  52.   CALLOCGROW=10;                  { number of entries to grow rgProc32Entry by}
  53.   rgProc32handle:thandle=0;       { Handle auf globalen Speicherbereich fⁿr rgProc32Entry }
  54.  
  55. { These are the addresses of the Generic Thunk functions in 
  56.   the WOW KERNEL.}  
  57.   fGotProcs:bool=FALSE;        { Did we successfully get the addresses? }
  58.  
  59. var
  60.   Callproc32W:function (address:pointer;n,c:longint):longint;
  61.   FreeLibrary32W:function(handle:longint):bool;
  62.   GetProcAddress32W:function(module:longint;funcname:pchar):pointer;
  63.   LoadLibraryEx32W:function(libname:pchar;a,b:longint):longint;
  64.   lpvGetLastError:function:pchar;
  65.   lpvGetCapture:pointer;
  66.  
  67. procedure Call32(iProc:longint);
  68. function Declare32(lpstrName,lpstrLib,lpstrArg:pchar):longint;
  69. function GetVDMPointer32W(name:pchar;Length:word):longint;    {Get 32-bit pointer from 16-bit pointer and length}
  70.  
  71. implementation
  72.  
  73.  
  74.  
  75. {/-----------------------------------------------------
  76. // XlatHwnd
  77. //   Translates a 16-bit HWND into a 32-bit HWND.
  78. //   The HWND must be one in our 16-bit process.
  79. //   NULL is translated to NULL and doesn't cause
  80. //   and error.
  81. //
  82. //   Unfortunately, WOW does not export a function
  83. //   for doing this, so our procedure is as follows:
  84. //   We do 16-bit SetCapture call to the window
  85. //   to set the capture, and then a 32-bit GetCapture
  86. //   call to get the 32-bit equivalent handle.  The
  87. //   capture is then restored to what it was beforehand.
  88. //
  89. //   May cause VB runtime error, and hence never return.
  90. //-----------------------------------------------------}
  91. procedure XlatHwnd(var phwnd:longint);
  92. var hwnd16,
  93.     hwndCapturePrev:word;
  94.     hwnd32,
  95.     hinstUser:longint;
  96.  
  97. begin
  98.   hwnd16:=LOWORD(phwnd);         { 16-bit hwnd }
  99.  
  100.   { Check for valid 16-bit handle. }  
  101.   if (phwnd<>word(hwnd16)) then exit; 
  102.   if (hwnd16<>0) and not IsWindow(hwnd16) then exit;
  103.  
  104.   { Get Address of 32-bit GetCapture }
  105.   if (@lpvGetCapture=nil) then begin
  106.     hinstUser:=LoadLibraryEx32W('user32', 0, 0);
  107.     if (hinstUser<>0) then begin
  108.       lpvGetCapture:=GetProcAddress32W(hinstUser, 'GetCapture');
  109.       FreeLibrary32W(hinstUser);
  110.     end;
  111.     if (@lpvGetCapture=nil) then exit;
  112.   end;
  113.  
  114.   
  115.   {/ Set capture to window, get capture to get 32-bit handle. 
  116.   // Be sure to restore capture afterward.
  117.   // NULL isn't translated }
  118.   
  119.   if (hwnd16<>0) then begin
  120.     hwndCapturePrev:=SetCapture(hwnd16);
  121.     hwnd32:=CallProc32W(lpvGetCapture,0,0);
  122.     if (hwndCapturePrev<>0) then
  123.       SetCapture(hwndCapturePrev)
  124.     else
  125.       ReleaseCapture;
  126.     if (hwnd32=0) then exit;
  127.   end;
  128.  
  129.   phwnd:=hwnd32;
  130. end;
  131.  
  132. {/-----------------------------------------------------
  133. // MungeArgs
  134. //   Modify the args array so it can be passed to
  135. //   to CallProc32W.  This uses the PROC32ENTRY structure
  136. //   to set up the arg list correctly on the stack
  137. //   so CallProc32W can be call.  HWND translation is
  138. //   performed.  The frame is changed as follows:
  139. //           In:                 Out:
  140. //            unused              number of params
  141. //   dwArgs-> unused              address xlat mask
  142. //            PROC32ENTRY index   32-bit function address.
  143. //            argument            argument, possible HWND xlated
  144. //            argument            argument, possible HWND xlated
  145. //            ...                 ...
  146. //-----------------------------------------------------}
  147. type plongint=^longint;
  148.      pfarproc=^tfarproc;
  149. procedure MungeArgs(dwArgs:longint);
  150. var pentry:pPROC32ENTRY;
  151.     iArg:integer;
  152.     dwHwndXlat:longint;
  153.  
  154. begin
  155.   pentry:=@rgProc32Entry^[plongint(dwArgs+4)^];
  156.   iArg:=2;
  157.  
  158.   plongint(dwArgs-4)^:=pentry^.nParams;
  159.   plongint(dwArgs)^:=pentry^.dwAddrXlat;
  160.   pfarproc(dwArgs+4)^:=pentry^.lpfunc;
  161.   dwHwndXlat:=pentry^.dwHwndXlat;
  162.   while (dwHwndXlat<>0) do begin
  163.     if (dwHwndXlat and 1)<>0 then 
  164.     XlatHwnd(plongint(dwArgs+4*iArg)^);
  165.     inc(iArg);
  166.     dwHwndXlat:=dwHwndXlat shr 1;
  167.   end;
  168. end;
  169.  
  170. {/-----------------------------------------------------
  171. // Call32
  172. //   This function is called by applications directly.
  173. //   Arguments to the function are also on the stack 
  174. //   (iProc is the PROC32ENTRY index).  We correctly
  175. //   set up the stack frame, then JUMP to CallProc32W,
  176. //   which eventually returns to the user.
  177. //-----------------------------------------------------}
  178.  
  179. var dest:tfarproc;          {Destination for jump back!}
  180. var addit:word;             {value to add to sp to restore stack pointer}
  181. var _sp,_bp:word;
  182.  
  183. procedure Call32(iProc:longint);
  184. begin
  185.   if iProc<0 then begin      {Procedure is invalid -> stop execution!}
  186.     if messagebox(0,'Error calling 32 bit function, continue?','Call32',
  187.       mb_yesno or mb_iconquestion)=idno then halt(1);
  188.     addit:=(-iProc) shl 2;  {4 more for id!}
  189.     asm
  190.       mov sp,bp
  191.       pop bp
  192.       pop di
  193.       mov word(dest),di
  194.       pop di
  195.       mov word(dest+2),di
  196.       add sp,addit
  197.       xor ax,ax             {return 0}
  198.       xor dx,dx
  199.       jmp dest
  200.     end;
  201.   end;
  202.  
  203.   asm                       { here comes the thunking call! }
  204.     pop     bp              { restore BP }
  205.     mov     bx, sp          { bx = sp on entry }
  206.     sub     sp, 8           { 2 additional words }
  207.     mov     ax, ss:[bx]     { ax = return address offst }
  208.     mov     dx, ss:[bx+2]   { dx = return address segment }
  209.     mov     ss:[bx-8], ax
  210.     mov     ss:[bx-6], dx
  211.     push    ds              { Save our DS }
  212.     push    ss
  213.     push    bx              { Push pointer to args }
  214.     call    MungeArgs       { Munge the args }
  215.     pop     es              { es is our DS }
  216.     jmp    CallProc32W      { Jump to the call thunker }
  217.   end;
  218. end;
  219.   
  220. {/-----------------------------------------------------
  221. // Declare32
  222. //   This function is called directly from VB.
  223. //   It allocates and fills in a PROC32ENTRY structure
  224. //   so that we can call the 32 bit function.
  225. //-----------------------------------------------------}
  226. function Declare32(lpstrName,lpstrLib,lpstrArg:pchar):longint;
  227. var
  228.   hinst:longint;                   { 32-bit DLL instance handle }
  229.   lpfunc:pointer;                  { 32-bit function pointer    }
  230.   dwAddrXlat,                      { address xlat mask          }
  231.   dwHwndXlat,                      { hwnd xlat mask             }
  232.   nParams:longint;                 { number of params           }
  233.   szBuffer:array[0..127] of char;  { scratch buffer             }
  234.   hinstKernel:word;                { Instance handle of WOW KERNEL.DLL }
  235.   hinstKernel32:longint;           { Instance handle of Win32 KERNEL32.DLL }
  236.   rg:record
  237.     lpstrName:pchar;
  238.     nparams:longint;
  239.   end;
  240.   olderror:boolean;                { Was there an error before?}
  241.  
  242. begin
  243.   {/ First time called, get the addresses of the Generic Thunk
  244.   // functions.  Raise VB runtime error if can't (probably because
  245.   // we're not running on NT). }
  246.   olderror:=Call32NTError;
  247.   Call32NTError:=true;
  248.   Declare32:=-1-lstrlen(lpstrArg);
  249.   if not fGotProcs then begin
  250.     hinstKernel:=LoadLibrary('KERNEL');
  251.     if (hinstKernel < 32) then exit;
  252.  
  253.     @CallProc32W:=GetProcAddress(hinstKernel, 'CALLPROC32W');
  254.     @FreeLibrary32W:=GetProcAddress(hinstKernel, 'FREELIBRARY32W');
  255.     @LoadLibraryEx32W:=GetProcAddress(hinstKernel, 'LOADLIBRARYEX32W');
  256.     @GetProcAddress32W:=GetProcAddress(hinstKernel, 'GETPROCADDRESS32W');
  257.     FreeLibrary(hinstKernel);
  258.  
  259.     if (@LoadLibraryEx32W<>nil) and (@GetProcAddress32W<>nil) and (@FreeLibrary32W<>nil) then begin
  260.       hinstKernel32:=LoadLibraryEx32W('kernel32', 0, 0);
  261.       @lpvGetLastError:=GetProcAddress32W(hinstKernel32, 'GetLastError');
  262.       FreeLibrary32W(hinstKernel);
  263.     end;
  264.  
  265.     if (@CallProc32W=nil) or (@FreeLibrary32W=nil) or (@LoadLibraryEx32W=nil) or
  266.        (@GetProcAddress32W=nil) or (@lpvGetLastError=nil) then begin
  267.       exit;
  268.     end;
  269.     fGotProcs:=TRUE;
  270.   end;  
  271.  
  272.   { If needed, allocate a PROC32ENTRY structure }
  273.   if (cRegistered = cAlloc) then begin
  274.     if (rgProc32Entry<>nil) then begin
  275.       globalunlock(rgProc32handle);
  276.       rgProc32handle:=GlobalReAlloc(rgProc32handle,
  277.                        (cAlloc + CALLOCGROW) * sizeof(tPROC32ENTRY), GMEM_MOVEABLE);
  278.       rgProc32Entry:=Globallock(rgProc32handle);
  279.     end else begin
  280.       rgProc32handle:=GlobalAlloc(GMEM_MOVEABLE, CALLOCGROW * sizeof(tPROC32ENTRY));
  281.       rgProc32Entry:=Globallock(rgProc32handle);
  282.     end;
  283.     if (rgProc32Entry=nil) then exit;
  284.     inc(cAlloc,CALLOCGROW);
  285.   end;
  286.   
  287.   {/ Process the arg list descriptor string to 
  288.   // get the hwnd and addr translation masks, and the
  289.   // number of args. }
  290.  
  291.   dwAddrXlat:=0;
  292.   dwHwndXlat:=0;
  293.   nParams:=lstrlen(lpstrArg);
  294.   if (nParams > 32) then exit;  {Too many parameters}
  295.  
  296.   while (lpstrArg[0]<>#0) do begin
  297.     dwAddrXlat:=dwAddrXlat shl 1;
  298.     dwHwndXlat:=dwHwndXlat shl 1;
  299.     case lpstrArg[0] of
  300.       'p':dwAddrXlat:=dwAddrXlat or 1;
  301.       'i': ;
  302.       'w':dwHwndXlat:=dwHwndXlat or 1;
  303.     else
  304.       exit;
  305.     end;
  306.     inc(lpstrArg);
  307.   end;
  308.  
  309.   {/ Load the 32-bit library. } 
  310.   hinst:=LoadLibraryEx32W(lpstrLib, 0, 0);
  311.   if (hinst=0) then begin
  312.     exit;
  313.   end;
  314.   
  315.   {/ Get the 32-bit function address.  Try the following three
  316.   // variations of the name (example: NAME):
  317.   //    NAME
  318.   //    _NAME@nn     (stdcall naming convention: nn is bytes of args)
  319.   //    NAMEA        (Win32 ANSI function naming convention) }
  320.   lpfunc:=GetProcAddress32W(hinst, lpstrName);
  321.   if (lpfunc=nil) and (lstrlen(lpstrName) < 122) then begin
  322.     { Change to stdcall naming convention. }
  323.     rg.lpstrName:=lpstrName;
  324.     rg.nparams:=nParams * 4;
  325.     wvsprintf(szBuffer, '_%s@%d', rg);
  326.     lpfunc:=GetProcAddress32W(hinst, szBuffer);
  327.   end;  
  328.   if (lpfunc=nil) and (lstrlen(lpstrName) < 126) then begin
  329.     { Add suffix "A" for ansi }
  330.     strcopy(szBuffer, lpstrName);
  331.     strcat(szBuffer, 'A');
  332.     lpfunc:=GetProcAddress32W(hinst, szBuffer);
  333.   end;
  334.   if (lpfunc=nil) then begin
  335.     FreeLibrary32W(hinst);
  336.     exit;
  337.   end;
  338.   
  339.   {/ Fill in PROC32ENTRY struct and return index. }
  340.   rgProc32Entry^[cRegistered].hinst:=hinst;
  341.   rgProc32Entry^[cRegistered].lpfunc:=lpfunc;
  342.   rgProc32Entry^[cRegistered].dwAddrXlat:=dwAddrXlat;
  343.   rgProc32Entry^[cRegistered].dwHwndXlat:=dwHwndXlat;
  344.   rgProc32Entry^[cRegistered].nParams:=nParams;
  345.   Declare32:=cRegistered;
  346.   inc(cRegistered);
  347.   Call32NTError:=olderror;  {If there was no error, set Call32NTErrorOccurred to false}
  348. end;
  349.  
  350. function GetVDMPointer32W(name:pchar;Length:word):longint;
  351. var lpGetVDMPointer32W:function(name:pchar;UINT:word):longint;
  352. begin
  353.   @lpGetVDMPointer32W:=getProcAddress(GetModuleHandle('kernel'),'GetVDMPointer32W');
  354.   if @lpGetVDMPointer32W<>nil then
  355.     GetVDMPointer32W:=lpGetVDMPointer32W(name,Length)
  356.   else
  357.     GetVDMPointer32W:=0;
  358. end;
  359.  
  360. {/-----------------------------------------------------
  361. // WEP
  362. //   Called when DLL is unloaded.  We free all the
  363. //   32-bit DLLs we were using and clear the
  364. //   PROC32ENTRY list.
  365. //-----------------------------------------------------}
  366. var exitsave:tfarproc;
  367.  
  368. procedure cleanuplibs; far;
  369. begin
  370.   Exitproc:=Exitsave;
  371.   dec(cRegistered);
  372.   while (cRegistered >= 0) do begin 
  373.     FreeLibrary32W(rgProc32Entry^[cRegistered].hinst);
  374.     dec(cregistered);
  375.   end;
  376.   if (rgProc32Entry<>nil) then begin
  377.     globalunlock(rgProc32handle);
  378.     GlobalFree(rgProc32handle);
  379.   end;
  380.   rgProc32Entry:=NIL;
  381.   rgProc32handle:=0;
  382.   cRegistered:=0;
  383.   cAlloc:=0;
  384. end;
  385.  
  386. begin
  387.   @Callproc32W:=nil;
  388.   @FreeLibrary32W:=nil;
  389.   @GetProcAddress32W:=nil;
  390.   @LoadLibraryEx32W:=nil;
  391.   @lpvGetLastError:=nil;
  392.   lpvGetCapture:=nil;
  393.   exitsave:=exitproc;      
  394.   exitproc:=@cleanuplibs;
  395. end.
  396.